
;; =============================================================================
;; codegen context
(defstruct c-codegen-context
  (ostream nil :type stream)		; output stream
  (aliases nil :type hash-table)        ; symbol-to-string aliases map
  )


;; =============================================================================
;; stringifies given symbol
(defun alias-of (context sym)
  (check-type sym symbol)
  (let ((result (gethash sym (c-codegen-context-aliases context))))
    ;;(unless result (error "corresponding alias has not been found"))
    (if result result (princ-to-string sym))
    ;;result
    ))

;; =============================================================================
;; c-expression expansion
(defmacro def-expr-handler (func-id func-body &rest mapping-list)
  `(cond
     ,@(loop for i in mapping-list collect
	    `((eq ',(car i) ,func-id)
	      (destructuring-bind ,(cadr i) ; lambda-list
		  ,func-body ; source list
		,@(cddr i) ; form
		t ; result (indicates that form has been handled)
		)))
     (t nil)))

;; =============================================================================
;; printing facility

;; distinguishing facility
(defun sequence-form (context form)
  (cond
    ;; string
    ((stringp form) form)
    ;; character or number
    ((or (numberp form) (characterp form)) (princ-to-string form))
    ;; symbol (results in alias expansion)
    ((symbolp form) (alias-of context form))
    ;; unknown
    (t (error "unknown form"))))

;; writes char n times
(defun write-char-nth (ostream count ch)
  (check-type ch character)
  (let ((str (princ-to-string ch)))
    (dotimes (i count)
      (write-sequence str ostream)))
  t)

;; writes char to the given ostream, returns t
(defun write-chars (ostream &rest sequence)
  (dolist (ch sequence)
    (check-type ch character)
    (write-sequence (princ-to-string ch) ostream))
  t)

;; provides indentation
(defun prn-indented (context a)
  (let ((ostream (c-codegen-context-ostream context)))
    (case a
      ;; {
      (#\{ (write-chars ostream #\Newline #\{ #\Newline))

      ;; }
      (#\} (write-chars ostream #\} #\Newline))

      ;; ";"
      (#\; (write-chars ostream #\; #\Newline))
      )))

;; toplevel print function to be used by clients
(defun prn (context &rest args)
  (dolist (a args)
    ;; check for indentation form
    (unless (prn-indented context a)
      ;; write form itself if no indentation found
      (write-sequence (sequence-form context a) (c-codegen-context-ostream context)))))


;; =============================================================================
;; code generator

;; toplevel expressions
(defun c-gen-toplev (context expr)
  (let ((func-id (car expr)) (func-body (cdr expr)))
    ;; cond expansion that processes the given expression
    (def-expr-handler
	func-id				; bound function id
	func-body			; bound function body

      ;; functions

      ;; #include "header"
      (include-local (name)
		     (prn context "#include" #\Space #\" name #\" #\Newline))

      ;; #include <header>
      (include-global (name)
		      (prn context "#include" #\Space #\< name #\> #\Newline))

      ;; function declaration, e.g. int foo(int arg) { return arg+5; }
      (func ((f-type f-name) (&rest f-args) &rest body)
	    ;; print type and name
	    (prn context f-type " " f-name)

	    ;; print arglist
	    (prn context #\()
	    (let (next-arg)
	      (loop for (a-type a-name) (symbol symbol) in f-args
		 do (progn
		      (if next-arg
			  (prn context ", ")
			  (setf next-arg t))
		      (prn context a-type #\Space a-name))))
	    (prn context #\))

	    (if (null body)
		(prn context #\;)	; forward declaration
		(c-gen-block context body)))

      ;; structure declaration
      (struct (name &rest fields)
	      (prn context "struct" #\Space name #\{)
	      ;; print each field
	      (loop for (fld-type fld-name) (symbol symbol) in fields
		   do (prn context fld-type #\Space fld-name #\;))
	      (prn context
		   "}"			; this is to not to let printer do indenting
		   #\;))

      ;; preprocessor #if
      (pp-if (expr)
	     (prn context "#if ")
	     (c-gen-pp-expr context expr)
	     (prn context #\Newline))

      ;; #else
      (pp-else () (prn context "#else" #\Newline))

      ;; #endif
      (pp-endif () (prn context "#endif" #\Newline))
      )))


;; helper printer function for bin op
(defun pp-print-bin-op (context op-str left-expr right-expr)
  ;; leading brace + left expression
  (prn context #\( #\() (c-gen-pp-expr context left-expr)
  (prn context #\) op-str)		; trailing brace with op sign
  ;; right expression + trailing brace
  (prn context #\() (c-gen-pp-expr context right-expr) (prn context #\) #\)))

;; preprocessor expression (e.g. defined(FOO) && !defined(BOO))
(defun c-gen-pp-expr (context expr)
  (if (or (numberp expr) (symbolp expr))
      ;; leave expr it as it is in case of number or symbol
      (prn context expr)
      ;; non-null list is expected then
      (progn
	(check-type expr cons)
	(let ((func-id (car expr)) (func-body (cdr expr)))
	  (unless
	      (def-expr-handler
		  func-id		; bound function id
		  func-body		; bound function body

		;; defined(FOO)
		(defined (sym)
		    (check-type sym symbol)
		  (prn context "defined" #\( sym #\)))

		;; or
		(or (left-expr right-expr) (pp-print-bin-op context "||" left-expr right-expr))

		;; and
		(or (left-expr right-expr) (pp-print-bin-op context "||" left-expr right-expr))

		;; not
		(not (expr)
		     (prn context #\( "!" #\()
		     (c-gen-pp-expr context expr)
		     (prn context #\) #\)))
		)
	    (error "unknown preprocessor expression"))))))

;; expression in if operator conditions, var-initialization, etc.
(defun c-gen-line-expr (context expr)
  (cond
    ;; number
    ((numberp expr) (prn context expr))
    ;; string
    ((stringp expr) (prn context #\" expr #\"))
    ;; symbol (var)
    ((symbolp expr) (prn context expr))
    ;; unknown
    (t (error "unexpected expression"))))

(defun c-gen-block-expression (context expr)
  (let ((func-id (car expr)) (func-body (cdr expr)))
    (unless
	(def-expr-handler
	    func-id			; bound function id
	    func-body			; bound function body

	  ;; return {optional-value-expression}
	  (return (&optional return-expr)
		  (prn context "return")
		  (if return-expr
		    (progn
		      (prn context #\Space)
		      (c-gen-line-expr context return-expr))))

	  ;; let type variable &optional value
	  (let (var-type var-name &optional var-expr)
	    (prn context var-type #\Space var-name)
	    (if var-expr
		(progn
		  (prn context #\=)
		  (c-gen-line-expr context var-expr))))

	  ;; set variable expression
	  (set (var-name var-expr)
	       (prn context var-name #\=)
	       (c-gen-line-expr context var-expr))

	  ;; call func-name arglist
	  (call (func-name &rest arguments)
		(prn context func-name #\()
		(let (next-arg)
		  (dolist (arg arguments)
		    (if next-arg
			(prn context #\,)
			(setf next-arg t))
		    (c-gen-line-expr context arg)))
		(prn context #\)))
	  )
      (error "unknown block expression")))
  (prn context #\;))

(defun c-gen-block (context expr)
  (prn context #\{)
  (dolist (block-expression expr)
    (c-gen-block-expression context block-expression))
  (prn context #\}))

;; =============================================================================
;; creates test context
(defun make-test-codegen-context ()
  (make-c-codegen-context
   :ostream *standard-output*
   :aliases (make-hash-table)))

;; =============================================================================
;; processes toplev expressions in list
(defun process-toplev (&rest toplev-expr-list)
  (let ((context (make-test-codegen-context)))
    (dolist (toplev-expr toplev-expr-list)
      ;; put optional comments block that identifies source expr
      (if t
	  (progn
	    (prn context "/*" #\Newline)
	    (prn context (format nil "   ~a" toplev-expr))
	    (prn context #\Newline "*/" #\Newline)))
      ;; generate expression
      (c-gen-toplev context toplev-expr)
      ;; put newline
      (prn context #\Newline))))

;;
;;(setf cgc (make-test-codegen-context))
;;(process-toplev '(func (int main) ((int argc) (double argv))))
;;(c-gen-toplev cgc '(func (int main) ((int argc) (double argv)) (let int a 12) (return 0)))
;;(process-toplev '(func (int main) ((int argc) (double argv)) (let int a 12) (set a 100) (call printf "a = %d" a) (return 0)))
;;(process-toplev '(include-local "test.h"))
;;(process-toplev '(struct Foo (int a)))
;;
